home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istfr / ISTFR.MAC.f
Encoding:
Text File  |  1989-03-04  |  7.8 KB  |  264 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 3.1
  3. C---------------------------------------------------------
  4. C
  5. C  TOKEN STREAM BASED 'CLUGGE' PROGRAM!
  6. C  CHANGES FORMAT OF REAL NUMBERS..........
  7. C
  8.       PROGRAM ISTFR
  9.  
  10.       INTEGER TKNIN, TKNOUT, CMTIN, CMTOUT
  11.       INTEGER TKNINM(81), TKNONM(81),
  12.      +        CMTINM(81), CMTONM(81)
  13.  
  14.       INTEGER OPEN, CREATE, GETARG, READCF
  15.  
  16. C  Read paths from command file
  17.  
  18.       CALL ZINIT
  19.  
  20.       IF (GETARG(1,TKNINM,81).EQ.-100) CALL NAMES(1,TKNINM)
  21.       IF (GETARG(2,CMTINM,81).EQ.-100) CALL NAMES(2,CMTINM)
  22.       IF (GETARG(3,TKNONM,81).EQ.-100) CALL NAMES(3,TKNONM)
  23.       IF (GETARG(4,CMTONM,81).EQ.-100) CALL NAMES(4,CMTONM)
  24. C       Open required files
  25.  
  26.       TKNIN =OPEN(TKNINM,0)
  27.       IF (TKNIN .EQ.-1)
  28.      +      CALL ERROR('ISTFR unable to open input token file.')
  29.       CMTIN =OPEN(CMTINM,0)
  30.       IF (CMTIN .EQ.-1)
  31.      +      CALL ERROR('ISTFR unable to open input comment file.')
  32.       TKNOUT=CREATE(TKNONM,1)
  33.       IF (TKNOUT.EQ.-1)
  34.      +      CALL ERROR('ISTFR unable to open output token file.')
  35.       CMTOUT=CREATE(CMTONM,1)
  36.       IF (CMTOUT.EQ.-1)
  37.      +      CALL ERROR('ISTFR unable to open output comment file.')
  38.  
  39.       CALL TRNSFR(TKNIN, CMTIN, TKNOUT, CMTOUT)
  40.  
  41.       CALL ZMESS('[ISTFR: Normal Termination].', 1)
  42.       CALL ZQUIT(-2)
  43.  
  44.       END
  45. C-----------------------------------------------------------
  46. C
  47. C  PROMPT THE USER FOR NAMES THAT HAVE NOT BEEN SUPPLIED.......
  48. C
  49.       SUBROUTINE NAMES (NUMB,PATH)
  50.  
  51.       INTEGER NUMB,PATH(*)
  52.  
  53.       INTEGER ZGTCMD
  54.       INTEGER JUNK,PROMPT(22, 4)
  55.  
  56.       DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,
  57.      +116,111,107,101,110,32,102,105,108,101,58,32,129/
  58.      +(PROMPT(I,2),I=1,21)/73,110,112,117,116,32,99,
  59.      +111,109,109,101,110,116,32,102,105,108,101,58,32,129/
  60.      +(PROMPT(I,3),I=1,20)/79,117,116,112,117,116,32,
  61.      +116,111,107,101,110,32,102,105,108,101,58,32,129/
  62.      +(PROMPT(I,4),I=1,22)/79,117,116,112,117,116,32,
  63.      +99,111,109,109,101,110,116,32,102,105,
  64.      +108,101,58,32,129/
  65.  
  66.       CALL ZPRMPT(PROMPT(1,NUMB))
  67.       JUNK=ZGTCMD(PATH,0)
  68.  
  69.       END
  70. C-----------------------------------------------------------
  71. C
  72. C  TOKEN STREAM EDITOR, COPIES THE INPUT TOKEN STREAM TO THE
  73. C  OUTPUT TOKEN STREAM CHANGING THE FORMAT OF REAL NUMBERS
  74. C
  75.       SUBROUTINE TRNSFR(TKNIN, CMTIN, TKNOUT, CMTOUT)
  76.  
  77.       INTEGER TKNIN, CMTIN, TKNOUT, CMTOUT, TKNTYP, TKNLEN,
  78.      +        STATUS, I, J, DESCI, DESCO, POINT, SEP, PREVTK
  79.       INTEGER TKNSTR(1322), BUFFER(1322), TEMP(134)
  80.       INTEGER LENGTH, ZSETP, ZSETR, ZPREPL, ZTKGTI, ZTKPTI
  81.       LOGICAL INFMT
  82.  
  83. C---------------------------------------------------------
  84. C    TOOLPACK/1    Release: 2.4
  85. C---------------------------------------------------------
  86. C
  87. C  TKLAST = LAST TOKEN NUMBER
  88. C
  89.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  90.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  91.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  92.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  93.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  94.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  95.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  96.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  97.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  98.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  99.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  100.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  101.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  102.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  103.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  104.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  105.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  106.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  107.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  108.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  109.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  110.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  111.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  112.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  113.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  114.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  115.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  116.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  117.  
  118.  
  119.       PREVTK = 0
  120.       INFMT  = .FALSE.
  121.  
  122.       DESCI = ZTKGTI(1, TKNIN, CMTIN)
  123.       DESCO = ZTKPTI(1, TKNOUT, CMTOUT)
  124.       IF(DESCI .LE. 0 .OR. DESCO .LE. 0) RETURN
  125.  
  126.    10 CONTINUE
  127.         CALL ZGETTK(TKNTYP, TKNLEN, TKNSTR, DESCI, STATUS)
  128.         IF(TKNTYP .EQ. TRCNST  .OR. TKNTYP .EQ. TPCNST) THEN
  129.           CALL SCOPY(TKNSTR, 1, BUFFER, 1)
  130.           IF(TKNTYP .EQ. TRCNST) THEN
  131.             CALL DOVALX(0, BUFFER, TKNSTR, TKNLEN)
  132.           ELSE IF(TKNTYP .EQ. TPCNST) THEN
  133.             CALL DOVALX(1, BUFFER, TKNSTR, TKNLEN)
  134.           ENDIF
  135.         ENDIF
  136.         CALL ZPUTTK(TKNTYP, TKNLEN, TKNSTR, DESCO)
  137.       IF(TKNTYP .NE. TZEOF) GO TO 10
  138.  
  139.       END
  140. C-----------------------------------------------------------------------
  141. C
  142.       SUBROUTINE DOVALX(TYPEX, FROM, TO, TI)
  143.  
  144.       INTEGER TYPEX, I, FI, TI, EAT, BIGEXP, LETEXP
  145.       INTEGER ZLOWER, TYPE, CTOI
  146.       INTEGER FROM(*), TO(*)
  147.       LOGICAL UPE, DOH, DOP, DOF
  148.       COMMON /OPTION/ UPE, DOH, DOP, DOF
  149.       SAVE /OPTION/
  150.  
  151.       FI = 1
  152.       TI = 1
  153.       IF(TYPEX .EQ. 1) THEN
  154.         BIGEXP = 68
  155.         LETEXP = 100
  156.       ELSE
  157.         BIGEXP = 69
  158.         LETEXP = 101
  159.       ENDIF
  160. C
  161. C  WATCH FOR MANTISSA STARTING WITH A PERIOD
  162. C
  163.       IF(FROM(FI) .EQ. 46) THEN
  164.         TO(TI) = 48
  165.         TI = TI + 1
  166.         GO TO 100
  167.       ENDIF
  168. C
  169. C  COPY DIGITS OF MANTISSA PRECEEDING DECIMAL POINT
  170. C
  171.    10 CONTINUE
  172.       IF(TYPE(FROM(FI)) .EQ. 2) THEN
  173.         TO(TI) = FROM(FI)
  174.         FI = FI + 1
  175.         TI = TI + 1
  176.         GO TO 10
  177.  
  178.       ELSE IF(FROM(FI) .EQ. 129) THEN
  179.         TO(TI) = 46
  180.         TO(TI+1) = 48
  181.         TI = TI + 2
  182.         GO TO 1000
  183.  
  184.       ELSE IF(FROM(FI) .EQ. 46) THEN
  185.         GO TO 100
  186.  
  187.       ELSE IF(FROM(FI) .EQ. BIGEXP .OR. FROM(FI) .EQ. LETEXP) THEN
  188.         TO(TI) = 46
  189.         TO(TI+1) = 48
  190.         TO(TI+2) = BIGEXP
  191.         EAT = TI+2
  192.         FI = FI + 1
  193.         TI = TI + 3
  194.         GO TO 200
  195.  
  196.       ENDIF
  197. C
  198. C  DIGITS FOLLOWING DECIMAL POINT
  199. C
  200.   100 CONTINUE
  201.       TO(TI) = 46
  202.       FI = FI + 1
  203.       TI = TI + 1
  204.  
  205.    20 CONTINUE
  206.       IF(TYPE(FROM(FI)) .EQ. 2) THEN
  207.         TO(TI) = FROM(FI)
  208.         FI = FI + 1
  209.         TI = TI + 1
  210.         GO TO 20
  211.  
  212.       ELSE IF(FROM(FI) .EQ. 129) THEN
  213.         IF(TO(TI-1) .EQ. 46) THEN
  214.           TO(TI) = 48
  215.           TI = TI + 1
  216.         ENDIF
  217.         GO TO 1000
  218.  
  219.       ELSE IF(FROM(FI) .EQ. BIGEXP .OR. FROM(FI) .EQ. LETEXP) THEN
  220.         IF(TO(TI-1) .EQ. 46) THEN
  221.           TO(TI) = 48
  222.           TI = TI + 1
  223.         ENDIF
  224.         TO(TI) = BIGEXP
  225.         EAT = TI
  226.         FI = FI + 1
  227.         TI = TI + 1
  228.         GO TO 200
  229.  
  230.       ENDIF
  231. C
  232. C  HANDLE EXPONENT PART - OPTIONAL SIGN FIRST, DELETE IT IF THERE
  233. C  IS A ZERO EXPONENT (NOT FOR DOUBLE!!).....
  234. C
  235.   200 CONTINUE
  236.       IF(FROM(FI) .EQ. 45) THEN
  237.         TO(TI) = 45
  238.         FI = FI + 1
  239.         TI = TI + 1
  240.       ELSE IF(FROM(FI) .EQ. 43) THEN
  241.         FI = FI + 1
  242.       ENDIF
  243.       I = FI
  244.       IF(CTOI(FROM, I) .EQ. 0 .AND. TYPEX .NE. 1) THEN
  245.         TI = EAT
  246.  
  247.       ELSE
  248.    30   CONTINUE
  249.         IF(FROM(FI) .NE. 129) THEN
  250.           TO(TI) = FROM(FI)
  251.           FI = FI + 1
  252.           TI = TI + 1
  253.           GO TO 30
  254.         ENDIF
  255.       ENDIF
  256. C
  257. C  FINISH OFF THE STRING
  258. C
  259.  1000 CONTINUE
  260.       TO(TI) = 129
  261.       TI = TI - 1
  262.  
  263.       END
  264.